home *** CD-ROM | disk | FTP | other *** search
/ Windows Game Programming for Dummies (2nd Edition) / WinGamProgFD.iso / mac / DirectX SDK / DXSDK / samples / Multimedia / VBSamples / DirectPlay / DataRelay / frmDataRelay.frm next >
Text File  |  2001-10-08  |  28KB  |  733 lines
  1. VERSION 5.00
  2. Begin VB.Form frmDataRelay 
  3.    BorderStyle     =   3  'Fixed Dialog
  4.    Caption         =   "vbData Relay"
  5.    ClientHeight    =   6255
  6.    ClientLeft      =   645
  7.    ClientTop       =   930
  8.    ClientWidth     =   7755
  9.    Icon            =   "frmDataRelay.frx":0000
  10.    LinkTopic       =   "Form1"
  11.    MaxButton       =   0   'False
  12.    MinButton       =   0   'False
  13.    ScaleHeight     =   6255
  14.    ScaleWidth      =   7755
  15.    StartUpPosition =   3  'Windows Default
  16.    Begin VB.Frame Frame5 
  17.       Caption         =   "Connection Information"
  18.       Height          =   2715
  19.       Left            =   3240
  20.       TabIndex        =   23
  21.       Top             =   960
  22.       Width           =   4455
  23.       Begin VB.TextBox txtInfo 
  24.          BackColor       =   &H8000000F&
  25.          Height          =   1935
  26.          Left            =   120
  27.          MultiLine       =   -1  'True
  28.          ScrollBars      =   2  'Vertical
  29.          TabIndex        =   26
  30.          Top             =   660
  31.          Width           =   4155
  32.       End
  33.       Begin VB.ComboBox cboInfoTarget 
  34.          Height          =   315
  35.          Left            =   1380
  36.          Style           =   2  'Dropdown List
  37.          TabIndex        =   25
  38.          Top             =   240
  39.          Width           =   2655
  40.       End
  41.       Begin VB.Label Label1 
  42.          Alignment       =   1  'Right Justify
  43.          BackStyle       =   0  'Transparent
  44.          Caption         =   "Info Target: "
  45.          Height          =   195
  46.          Index           =   6
  47.          Left            =   300
  48.          TabIndex        =   24
  49.          Top             =   300
  50.          Width           =   1035
  51.       End
  52.    End
  53.    Begin VB.Timer tmrReceivedData 
  54.       Interval        =   1
  55.       Left            =   180
  56.       Top             =   3060
  57.    End
  58.    Begin VB.Timer tmrSendData 
  59.       Interval        =   1
  60.       Left            =   720
  61.       Top             =   3060
  62.    End
  63.    Begin VB.Frame Frame4 
  64.       Caption         =   "Statistics"
  65.       Height          =   915
  66.       Left            =   60
  67.       TabIndex        =   18
  68.       Top             =   2760
  69.       Width           =   3135
  70.       Begin VB.Label lblReceive 
  71.          BackStyle       =   0  'Transparent
  72.          Caption         =   "0.0"
  73.          Height          =   195
  74.          Left            =   2160
  75.          TabIndex        =   22
  76.          Top             =   480
  77.          Width           =   855
  78.       End
  79.       Begin VB.Label lblSendRate 
  80.          BackStyle       =   0  'Transparent
  81.          Caption         =   "0.0"
  82.          Height          =   195
  83.          Left            =   2160
  84.          TabIndex        =   21
  85.          Top             =   240
  86.          Width           =   795
  87.       End
  88.       Begin VB.Label Label1 
  89.          Alignment       =   1  'Right Justify
  90.          BackStyle       =   0  'Transparent
  91.          Caption         =   "Received Rate (bytes/sec) :"
  92.          Height          =   195
  93.          Index           =   8
  94.          Left            =   60
  95.          TabIndex        =   20
  96.          Top             =   480
  97.          Width           =   2055
  98.       End
  99.       Begin VB.Label Label1 
  100.          Alignment       =   1  'Right Justify
  101.          BackStyle       =   0  'Transparent
  102.          Caption         =   "Send Rate (bytes/sec) :"
  103.          Height          =   195
  104.          Index           =   7
  105.          Left            =   60
  106.          TabIndex        =   19
  107.          Top             =   240
  108.          Width           =   2055
  109.       End
  110.    End
  111.    Begin VB.Frame Frame3 
  112.       Caption         =   "Send"
  113.       Height          =   1755
  114.       Left            =   60
  115.       TabIndex        =   9
  116.       Top             =   960
  117.       Width           =   3135
  118.       Begin VB.ComboBox cboTimeout 
  119.          Height          =   315
  120.          Left            =   1200
  121.          Style           =   2  'Dropdown List
  122.          TabIndex        =   17
  123.          Top             =   1320
  124.          Width           =   1815
  125.       End
  126.       Begin VB.ComboBox cboTarget 
  127.          Height          =   315
  128.          Left            =   1200
  129.          Style           =   2  'Dropdown List
  130.          TabIndex        =   16
  131.          Top             =   240
  132.          Width           =   1815
  133.       End
  134.       Begin VB.ComboBox cboSize 
  135.          Height          =   315
  136.          Left            =   1200
  137.          Style           =   2  'Dropdown List
  138.          TabIndex        =   15
  139.          Top             =   600
  140.          Width           =   1815
  141.       End
  142.       Begin VB.ComboBox cboRate 
  143.          Height          =   315
  144.          Left            =   1200
  145.          Style           =   2  'Dropdown List
  146.          TabIndex        =   14
  147.          Top             =   960
  148.          Width           =   1815
  149.       End
  150.       Begin VB.Label Label1 
  151.          BackStyle       =   0  'Transparent
  152.          Caption         =   "Timeout (ms) :"
  153.          Height          =   195
  154.          Index           =   5
  155.          Left            =   120
  156.          TabIndex        =   13
  157.          Top             =   1380
  158.          Width           =   1035
  159.       End
  160.       Begin VB.Label Label1 
  161.          Alignment       =   1  'Right Justify
  162.          BackStyle       =   0  'Transparent
  163.          Caption         =   "Target :"
  164.          Height          =   195
  165.          Index           =   4
  166.          Left            =   120
  167.          TabIndex        =   12
  168.          Top             =   300
  169.          Width           =   1035
  170.       End
  171.       Begin VB.Label Label1 
  172.          Alignment       =   1  'Right Justify
  173.          BackStyle       =   0  'Transparent
  174.          Caption         =   "Size (bytes) :"
  175.          Height          =   195
  176.          Index           =   3
  177.          Left            =   120
  178.          TabIndex        =   11
  179.          Top             =   660
  180.          Width           =   1035
  181.       End
  182.       Begin VB.Label Label1 
  183.          Alignment       =   1  'Right Justify
  184.          BackStyle       =   0  'Transparent
  185.          Caption         =   "Rate (ms) :"
  186.          Height          =   195
  187.          Index           =   2
  188.          Left            =   120
  189.          TabIndex        =   10
  190.          Top             =   1020
  191.          Width           =   1035
  192.       End
  193.    End
  194.    Begin VB.Frame Frame2 
  195.       Caption         =   "Log"
  196.       Height          =   2415
  197.       Left            =   60
  198.       TabIndex        =   7
  199.       Top             =   3720
  200.       Width           =   7635
  201.       Begin VB.TextBox txtLog 
  202.          BackColor       =   &H8000000F&
  203.          Height          =   2055
  204.          Left            =   120
  205.          MultiLine       =   -1  'True
  206.          ScrollBars      =   3  'Both
  207.          TabIndex        =   8
  208.          Top             =   240
  209.          Width           =   7395
  210.       End
  211.    End
  212.    Begin VB.Frame Frame1 
  213.       Caption         =   "Game Status"
  214.       Height          =   855
  215.       Left            =   60
  216.       TabIndex        =   0
  217.       Top             =   60
  218.       Width           =   7635
  219.       Begin VB.CommandButton cmdExit 
  220.          Cancel          =   -1  'True
  221.          Caption         =   "Exit"
  222.          Height          =   375
  223.          Left            =   5880
  224.          TabIndex        =   6
  225.          Top             =   300
  226.          Width           =   1575
  227.       End
  228.       Begin VB.CommandButton cmdSend 
  229.          Caption         =   "Push to send"
  230.          Enabled         =   0   'False
  231.          Height          =   375
  232.          Left            =   4200
  233.          TabIndex        =   5
  234.          Top             =   300
  235.          Width           =   1575
  236.       End
  237.       Begin VB.Label lblPlayers 
  238.          BackStyle       =   0  'Transparent
  239.          Caption         =   "0"
  240.          Height          =   255
  241.          Left            =   2340
  242.          TabIndex        =   4
  243.          Top             =   480
  244.          Width           =   195
  245.       End
  246.       Begin VB.Label lblPlayer 
  247.          BackStyle       =   0  'Transparent
  248.          Caption         =   "TestPlayer"
  249.          Height          =   255
  250.          Left            =   1560
  251.          TabIndex        =   3
  252.          Top             =   240
  253.          Width           =   1635
  254.       End
  255.       Begin VB.Label Label1 
  256.          BackStyle       =   0  'Transparent
  257.          Caption         =   "Number of Players in session:"
  258.          Height          =   195
  259.          Index           =   1
  260.          Left            =   120
  261.          TabIndex        =   2
  262.          Top             =   480
  263.          Width           =   2175
  264.       End
  265.       Begin VB.Label Label1 
  266.          BackStyle       =   0  'Transparent
  267.          Caption         =   "Local Player Name:"
  268.          Height          =   195
  269.          Index           =   0
  270.          Left            =   120
  271.          TabIndex        =   1
  272.          Top             =   240
  273.          Width           =   1455
  274.       End
  275.    End
  276. End
  277. Attribute VB_Name = "frmDataRelay"
  278. Attribute VB_GlobalNameSpace = False
  279. Attribute VB_Creatable = False
  280. Attribute VB_PredeclaredId = True
  281. Attribute VB_Exposed = False
  282. Option Explicit
  283. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  284. '
  285. '  Copyright (C) 1999-2001 Microsoft Corporation.  All Rights Reserved.
  286. '
  287. '  File:       frmDataRelay.frm
  288. '
  289. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  290. 'Declare for timeGetTime
  291. Private Declare Function timeGetTime Lib "winmm.dll" () As Long
  292.  
  293. Implements DirectPlay8Event
  294. Private Const mlTextSize As Long = 32768
  295. Private Type PacketInfo
  296.     lPacketID As Long
  297.     lDataSize As Long
  298. End Type
  299.  
  300. Private mfSending As Boolean
  301. Private mlRate As Long
  302. Private mlToPlayerID As Long
  303. Private mlTimeOut As Long
  304. Private mlSize As Long
  305. Private mlSending As Long
  306. Private mlLastSendTime As Long
  307. Private mlDataReceived As Long
  308. Private mlDataSent As Long
  309. Private mfInSend As Boolean
  310. Private mfInReceive As Boolean
  311. Private moByte() As Byte, moBuf() As Byte 'DirectPlayBuffer
  312.  
  313. Private moReceived As New Collection
  314.  
  315. Private Sub cmdExit_Click()
  316.     'We're done, unload
  317.     Unload Me
  318. End Sub
  319.  
  320. Private Sub cmdSend_Click()
  321.     
  322.     If mfSending Then
  323.         'Stop sending now
  324.         cmdSend.Caption = "Push to send"
  325.     Else
  326.         'Start sending now
  327.         cmdSend.Caption = "Push to stop"
  328.         ReadCombos
  329.     End If
  330.     EnableComboUI mfSending
  331.     mfSending = Not mfSending
  332. End Sub
  333.  
  334. Private Sub Form_Load()
  335.     
  336.     'First lets populate our combo boxes
  337.     PopulateBoxes
  338.     'Here we will init our DPlay objects
  339.     InitDPlay
  340.     'Now we can create a new Connection Form (which will also be our message pump)
  341.     Set DPlayEventsForm = New DPlayConnect
  342.     'Start the connection form (it will either create or join a session)
  343.     If Not DPlayEventsForm.StartConnectWizard(dx, dpp, AppGuid, 20, Me) Then
  344.         Cleanup
  345.         End
  346.     Else 'We did choose to play a game
  347.         gsUserName = DPlayEventsForm.UserName
  348.         lblPlayer.Caption = gsUserName
  349.         If DPlayEventsForm.IsHost Then Me.Caption = Me.Caption & " (HOST)"
  350.     End If
  351.  
  352. End Sub
  353.  
  354. Private Sub Form_Unload(Cancel As Integer)
  355.     Me.Hide
  356.     'Here we need to turn off our timers
  357.     If mfSending Then cmdSend_Click
  358.     mfSending = False
  359.     Do While moReceived.Count > 0
  360.         DPlayEventsForm.DoSleep 50
  361.     Loop
  362.     tmrReceivedData.Enabled = False
  363.     tmrSendData.Enabled = False
  364.     Cleanup
  365. End Sub
  366.  
  367. Private Sub PopulateBoxes()
  368.     With cboTarget
  369.         .AddItem "Everyone"
  370.         .ListIndex = 0
  371.     End With
  372.     With cboRate
  373.         .AddItem "1000"
  374.         .AddItem "500"
  375.         .AddItem "250"
  376.         .AddItem "100"
  377.         .AddItem "50"
  378.         .ListIndex = 0
  379.     End With
  380.     With cboSize
  381.         .AddItem "512"
  382.         .AddItem "256"
  383.         .AddItem "128"
  384.         .AddItem "64"
  385.         .AddItem "32"
  386.         .AddItem "16"
  387.         .ListIndex = 0
  388.     End With
  389.     With cboTimeout
  390.         .AddItem "5"
  391.         .AddItem "10"
  392.         .AddItem "20"
  393.         .AddItem "50"
  394.         .AddItem "100"
  395.         .AddItem "250"
  396.         .AddItem "500"
  397.         .ListIndex = 0
  398.     End With
  399.     With cboInfoTarget
  400.         .AddItem "None"
  401.         .ListIndex = 0
  402.     End With
  403.     
  404. End Sub
  405.  
  406. Private Sub EnableComboUI(ByVal fEnable As Boolean)
  407.     cboRate.Enabled = fEnable
  408.     cboTarget.Enabled = fEnable
  409.     cboTimeout.Enabled = fEnable
  410.     cboSize.Enabled = fEnable
  411. End Sub
  412.  
  413. Private Sub ReadCombos()
  414.     mlRate = CLng(cboRate.List(cboRate.ListIndex))
  415.     mlSize = CLng(cboSize.List(cboSize.ListIndex))
  416.     mlTimeOut = CLng(cboTimeout.List(cboTimeout.ListIndex))
  417.     mlToPlayerID = cboTarget.ItemData(cboTarget.ListIndex) 'The ItemData for everyone is 0
  418. End Sub
  419.  
  420. Private Sub AppendText(ByVal sString As String)
  421.     'Update the chat window first
  422.     txtLog.Text = txtLog.Text & sString & vbCrLf
  423.     'Now limit the text in the window to be 16k
  424.     If Len(txtLog.Text) > mlTextSize Then
  425.         txtLog.Text = Right$(txtLog.Text, mlTextSize)
  426.     End If
  427.     'Autoscroll the text
  428.     txtLog.SelStart = Len(txtLog.Text)
  429. End Sub
  430.  
  431. Private Function GetName(ByVal lID As Long) As String
  432.     Dim lCount As Long
  433.     
  434.     'Here we will get the name of the player sending us info from the combo box
  435.     GetName = vbNullString
  436.     For lCount = 0 To cboTarget.ListCount - 1
  437.         If cboTarget.ItemData(lCount) = lID Then 'This is the player
  438.             GetName = cboTarget.List(lCount)
  439.             Exit For
  440.         End If
  441.     Next
  442. End Function
  443.  
  444. Private Sub tmrReceivedData_Timer()
  445.     Dim oBuf() As Byte, lNewMsg As Long, lNewOffset As Long
  446.     Dim sItems() As String, oPacket As PacketInfo
  447.     
  448.     'If mfInReceive Then Exit Sub
  449.     'We use a timer control here because we don't want to ever
  450.     'block DirectPlay.
  451.     Do While moReceived.Count > 0
  452.         mfInReceive = True
  453.         sItems = Split(moReceived.Item(1), ";")
  454.         AppendText "Received packet #" & sItems(1) & " from " & GetName(CLng(sItems(0))) & " - Size:" & sItems(2)
  455.         'now let this user know we received the packet
  456.         lNewMsg = MSG_PacketReceive
  457.         lNewOffset = NewBuffer(oBuf)
  458.         AddDataToBuffer oBuf, lNewMsg, LenB(lNewMsg), lNewOffset
  459.         oPacket.lDataSize = CLng(sItems(2))
  460.         oPacket.lPacketID = CLng(sItems(1))
  461.         mlDataReceived = mlDataReceived + oPacket.lDataSize
  462.         AddDataToBuffer oBuf, oPacket, LenB(oPacket), lNewOffset
  463.         'We don't care to see the receive callback.
  464.         dpp.SendTo CLng(sItems(0)), oBuf, mlTimeOut, DPNSEND_NOLOOPBACK
  465.         Erase oBuf
  466.         moReceived.Remove 1
  467.     Loop
  468.     mfInReceive = False
  469. End Sub
  470.  
  471. Private Sub tmrSendData_Timer()
  472.     Dim lMsg As Long, lOffset As Long
  473.     Dim oPacket As PacketInfo
  474.  
  475.     'We use a timer control here because we don't want to ever
  476.     'block DirectPlay.
  477.     'If mfInSend Then Exit Sub
  478.     If mfSending Then 'We are sending
  479.         If Abs(timeGetTime - mlLastSendTime) > mlRate Then 'We should send another packet now
  480.             mfInSend = True
  481.             lMsg = MSG_GamePacket
  482.             lOffset = NewBuffer(moBuf)
  483.             AddDataToBuffer moBuf, lMsg, LenB(lMsg), lOffset
  484.             mlSending = mlSending + 1
  485.             oPacket.lPacketID = mlSending
  486.             oPacket.lDataSize = mlSize
  487.             mlDataSent = mlDataSent + mlSize
  488.             AddDataToBuffer moBuf, oPacket, LenB(oPacket), lOffset
  489.             ReDim moByte(mlSize)
  490.             AddDataToBuffer moBuf, moByte(0), mlSize, lOffset
  491.             'We will send the NOLOOPBACK flag so we do not get a 'Receive' event for
  492.             'this message.
  493.             'The NOCOPY flag tells DPlay not to copy our buffer.  We will erase the buffer in the
  494.             'SendComplete event
  495.             dpp.SendTo mlToPlayerID, moBuf, mlTimeOut, DPNSEND_NOLOOPBACK Or DPNSEND_NOCOPY
  496.             mlLastSendTime = timeGetTime
  497.         End If
  498.     End If
  499.     'Regardless of what's going on, we should update our ui
  500.     UpdateStats
  501. End Sub
  502.  
  503. Private Sub UpdateStats()
  504.     Dim lNumMsgs As Long, lNumBytes As Long
  505.     Dim lCurTime As Long
  506.     Dim sText As String, dpnInfo As DPN_CONNECTION_INFO
  507.     Dim lNumMsgHigh As Long, lNumByteHigh As Long
  508.     Dim lNumMsgNormal As Long, lNumByteNormal As Long
  509.     Dim lNumMsgLow As Long, lNumByteLow As Long
  510.     Dim lDrops As Long, lSends As Long
  511.     Dim lPlayerID As Long
  512.     
  513.     On Error Resume Next
  514.     Static lLastTime As Long
  515.     
  516.     If lLastTime = 0 Then lLastTime = timeGetTime
  517.     lCurTime = timeGetTime
  518.  
  519.     If (lCurTime - lLastTime) < 1000 Then Exit Sub 'We don't need to update more than once a second
  520.         
  521.     Dim nSecondsPassed As Single, nDataIn As Single
  522.     Dim nDataOut As Single
  523.     
  524.     nSecondsPassed = (lCurTime - lLastTime) / 1000
  525.     nDataIn = mlDataReceived / nSecondsPassed
  526.     nDataOut = mlDataSent / nSecondsPassed
  527.     lLastTime = lCurTime
  528.     mlDataReceived = 0
  529.     mlDataSent = 0
  530.  
  531.     lblSendRate.Caption = Format$(CStr(nDataOut), "0.0#")
  532.     lblReceive.Caption = Format$(CStr(nDataIn), "0.0#")
  533.     
  534.     If cboInfoTarget.ListIndex >= 0 Then
  535.         lPlayerID = cboInfoTarget.ItemData(cboInfoTarget.ListIndex)
  536.         If lPlayerID <> 0 Then
  537.             'Update the connection info
  538.             dpnInfo = dpp.GetConnectionInfo(lPlayerID, 0)
  539.             dpp.GetSendQueueInfo lPlayerID, lNumMsgHigh, lNumByteHigh, DPNGETSENDQUEUEINFO_PRIORITY_HIGH
  540.             dpp.GetSendQueueInfo lPlayerID, lNumMsgLow, lNumByteLow, DPNGETSENDQUEUEINFO_PRIORITY_LOW
  541.             dpp.GetSendQueueInfo lPlayerID, lNumMsgNormal, lNumByteNormal, DPNGETSENDQUEUEINFO_PRIORITY_NORMAL
  542.             lDrops = dpnInfo.lPacketsDropped + dpnInfo.lPacketsRetried
  543.             lDrops = lDrops * 10000
  544.             lSends = dpnInfo.lPacketsSentGuaranteed + dpnInfo.lPacketsSentNonGuaranteed
  545.     
  546.             If lSends > 0 Then lDrops = lDrops \ lSends
  547.             
  548.             sText = "Send Queue Messages High Priority=" & CStr(lNumMsgHigh) & vbCrLf
  549.             sText = sText & "Send Queue Bytes High Priority=" & CStr(lNumByteHigh) & vbCrLf
  550.             sText = sText & "Send Queue Messages Normal Priority=" & CStr(lNumMsgNormal) & vbCrLf
  551.             sText = sText & "Send Queue Bytes Normal Priority=" & CStr(lNumByteNormal) & vbCrLf
  552.     
  553.             sText = sText & "Send Queue Messages Low Priority=" & CStr(lNumMsgLow) & vbCrLf
  554.             sText = sText & "Send Queue Bytes Low Priority=" & CStr(lNumByteLow) & vbCrLf
  555.     
  556.             sText = sText & "Round Trip Latency MS=" & CStr(dpnInfo.lRoundTripLatencyMS) & " ms" & vbCrLf
  557.             sText = sText & "Throughput BPS=" & CStr(dpnInfo.lThroughputBPS) & vbCrLf
  558.             sText = sText & "Peak Throughput BPS=" & CStr(dpnInfo.lPeakThroughputBPS) & vbCrLf
  559.                                                                             
  560.             sText = sText & "Bytes Sent Guaranteed=" & CStr(dpnInfo.lBytesSentGuaranteed) & vbCrLf
  561.             sText = sText & "Packets Sent Guaranteed=" & CStr(dpnInfo.lPacketsSentGuaranteed) & vbCrLf
  562.             sText = sText & "Bytes Sent Non-Guaranteed=" & CStr(dpnInfo.lBytesSentNonGuaranteed) & vbCrLf
  563.             sText = sText & "Packets Sent Non-Guaranteed=" & CStr(dpnInfo.lPacketsSentNonGuaranteed) & vbCrLf
  564.                                                                             
  565.             sText = sText & "Bytes Retried Guaranteed=" & CStr(dpnInfo.lBytesRetried) & vbCrLf
  566.             sText = sText & "Packets Retried Guaranteed=" & CStr(dpnInfo.lPacketsRetried) & vbCrLf
  567.             sText = sText & "Bytes Dropped Non-Guaranteed=" & CStr(dpnInfo.lBytesDropped) & vbCrLf
  568.             sText = sText & "Packets Dropped Non-Guaranteed=" & CStr(dpnInfo.lPacketsDropped) & vbCrLf
  569.                                                                             
  570.             sText = sText & "Messages Transmitted High Priority=" & CStr(dpnInfo.lMessagesTransmittedHighPriority) & vbCrLf
  571.             sText = sText & "Messages Timed Out High Priority=" & CStr(dpnInfo.lMessagesTimedOutHighPriority) & vbCrLf
  572.             sText = sText & "Messages Transmitted Normal Priority=" & CStr(dpnInfo.lMessagesTransmittedNormalPriority) & vbCrLf
  573.             sText = sText & "Messages Timed Out Normal Priority=" & CStr(dpnInfo.lMessagesTimedOutNormalPriority) & vbCrLf
  574.             sText = sText & "Messages Transmitted Low Priority=" & CStr(dpnInfo.lMessagesTransmittedLowPriority) & vbCrLf
  575.             sText = sText & "Messages Timed Out Low Priority=" & CStr(dpnInfo.lMessagesTimedOutLowPriority) & vbCrLf
  576.                                                                             
  577.             sText = sText & "Bytes Received Guaranteed=" & CStr(dpnInfo.lBytesReceivedGuaranteed) & vbCrLf
  578.             sText = sText & "Packets Received Guaranteed=" & CStr(dpnInfo.lPacketsReceivedGuaranteed) & vbCrLf
  579.             sText = sText & "Bytes Received Non-Guaranteed=" & CStr(dpnInfo.lBytesReceivedNonGuaranteed) & vbCrLf
  580.             sText = sText & "Packets Received Non-Guaranteed=" & CStr(dpnInfo.lPacketsReceivedNonGuaranteed) & vbCrLf
  581.             sText = sText & "Messages Received=" & CStr(dpnInfo.lMessagesReceived) & vbCrLf
  582.                                                                             
  583.             sText = sText & "Loss Rate=" & CStr(lDrops \ 100) & "." & CStr(lDrops Mod 100) & vbCrLf
  584.             txtInfo.Text = sText
  585.         Else
  586.             txtInfo.Text = vbNullString
  587.         End If
  588.     End If
  589. End Sub
  590.  
  591. Private Sub DirectPlay8Event_AddRemovePlayerGroup(ByVal lMsgID As Long, ByVal lPlayerID As Long, ByVal lGroupID As Long, fRejectMsg As Boolean)
  592.     'VB requires that we must implement *every* member of this interface
  593. End Sub
  594.  
  595. Private Sub DirectPlay8Event_AppDesc(fRejectMsg As Boolean)
  596.     'VB requires that we must implement *every* member of this interface
  597. End Sub
  598.  
  599. Private Sub DirectPlay8Event_AsyncOpComplete(dpnotify As DxVBLibA.DPNMSG_ASYNC_OP_COMPLETE, fRejectMsg As Boolean)
  600.     'VB requires that we must implement *every* member of this interface
  601. End Sub
  602.  
  603. Private Sub DirectPlay8Event_ConnectComplete(dpnotify As DxVBLibA.DPNMSG_CONNECT_COMPLETE, fRejectMsg As Boolean)
  604.     If dpnotify.hResultCode <> 0 Then
  605.         'For some reason we could not connect.  All available slots must be closed.
  606.         MsgBox "Connect Failed.  Error: 0x" & CStr(Hex$(dpnotify.hResultCode)) & "  - This sample will now close.", vbOKOnly Or vbCritical, "Closing"
  607.         DPlayEventsForm.CloseForm Me
  608.     End If
  609. End Sub
  610.  
  611. Private Sub DirectPlay8Event_CreateGroup(ByVal lGroupID As Long, ByVal lOwnerID As Long, fRejectMsg As Boolean)
  612.     'VB requires that we must implement *every* member of this interface
  613. End Sub
  614.  
  615. Private Sub DirectPlay8Event_CreatePlayer(ByVal lPlayerID As Long, fRejectMsg As Boolean)
  616.     Dim lCount As Long
  617.     Dim dpPeer As DPN_PLAYER_INFO
  618.     
  619.     'When someone joins add them to the 'Target' combo box
  620.     'and update the number of players list
  621.     dpPeer = dpp.GetPeerInfo(lPlayerID)
  622.     If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) = 0 Then 'This isn't me add this user
  623.         cboTarget.AddItem dpPeer.Name
  624.         cboTarget.ItemData(cboTarget.ListCount - 1) = lPlayerID
  625.         cboInfoTarget.AddItem dpPeer.Name
  626.         cboInfoTarget.ItemData(cboInfoTarget.ListCount - 1) = lPlayerID
  627.     End If
  628.     'Update our player count,and enable the send button (if need be)
  629.     lblPlayers.Caption = CStr(cboTarget.ListCount)
  630.     cmdSend.Enabled = (cboTarget.ListCount > 1)
  631. End Sub
  632.  
  633. Private Sub DirectPlay8Event_DestroyGroup(ByVal lGroupID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
  634.     'VB requires that we must implement *every* member of this interface
  635. End Sub
  636.  
  637. Private Sub DirectPlay8Event_DestroyPlayer(ByVal lPlayerID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
  638.     Dim lCount As Long
  639.     Dim dpPeer As DPN_PLAYER_INFO
  640.     
  641.     'Remove this player from our list
  642.     For lCount = 0 To cboTarget.ListCount - 1
  643.         If cboTarget.ItemData(lCount) = lPlayerID Then 'This is the player
  644.             cboTarget.RemoveItem lCount
  645.             Exit For
  646.         End If
  647.     Next
  648.     For lCount = 0 To cboInfoTarget.ListCount - 1
  649.         If cboInfoTarget.ItemData(lCount) = lPlayerID Then 'This is the player
  650.             cboInfoTarget.RemoveItem lCount
  651.             Exit For
  652.         End If
  653.     Next
  654.     'Update our player count,and enable the send button (if need be)
  655.     lblPlayers.Caption = CStr(cboTarget.ListCount)
  656.     cmdSend.Enabled = (cboTarget.ListCount > 1)
  657.     'If we are sending, and there is no one left to send to, or the person we were sending too left, stop sending
  658.     If (mfSending) And ((cboTarget.ListCount = 0) Or (mlToPlayerID = lPlayerID)) Then cmdSend_Click
  659.     If cboInfoTarget.ListIndex < 0 Then cboInfoTarget.ListIndex = 0
  660.     If cboTarget.ListIndex < 0 Then cboTarget.ListIndex = 0
  661. End Sub
  662.  
  663. Private Sub DirectPlay8Event_EnumHostsQuery(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_QUERY, fRejectMsg As Boolean)
  664.     'VB requires that we must implement *every* member of this interface
  665. End Sub
  666.  
  667. Private Sub DirectPlay8Event_EnumHostsResponse(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_RESPONSE, fRejectMsg As Boolean)
  668.     'VB requires that we must implement *every* member of this interface
  669. End Sub
  670.  
  671. Private Sub DirectPlay8Event_HostMigrate(ByVal lNewHostID As Long, fRejectMsg As Boolean)
  672.     Dim dpPeer As DPN_PLAYER_INFO
  673.     dpPeer = dpp.GetPeerInfo(lNewHostID)
  674.     If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) = DPNPLAYER_LOCAL Then 'I am the new host
  675.         Me.Caption = Me.Caption & " (HOST)"
  676.     End If
  677. End Sub
  678.  
  679. Private Sub DirectPlay8Event_IndicateConnect(dpnotify As DxVBLibA.DPNMSG_INDICATE_CONNECT, fRejectMsg As Boolean)
  680.     'VB requires that we must implement *every* member of this interface
  681. End Sub
  682.  
  683. Private Sub DirectPlay8Event_IndicatedConnectAborted(fRejectMsg As Boolean)
  684.     'VB requires that we must implement *every* member of this interface
  685. End Sub
  686.  
  687. Private Sub DirectPlay8Event_InfoNotify(ByVal lMsgID As Long, ByVal lNotifyID As Long, fRejectMsg As Boolean)
  688.     'VB requires that we must implement *every* member of this interface
  689. End Sub
  690.  
  691. Private Sub DirectPlay8Event_Receive(dpnotify As DxVBLibA.DPNMSG_RECEIVE, fRejectMsg As Boolean)
  692.     'All we care about in this demo is what msgs we receive.
  693.     Dim lMsg As Long, lOffset As Long
  694.     Dim oPacket As PacketInfo
  695.     
  696.     With dpnotify
  697.     GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
  698.     Select Case lMsg
  699.     Case MSG_GamePacket 'We received a packet
  700.         'Update the UI showing we received the packet
  701.         GetDataFromBuffer .ReceivedData, oPacket, LenB(oPacket), lOffset
  702.         moReceived.Add CStr(dpnotify.idSender) & ";" & CStr(oPacket.lPacketID) & ";" & CStr(oPacket.lDataSize)
  703.     Case MSG_PacketReceive 'They received a packet we sent
  704.         'Update the UI showing we received the packet
  705.         GetDataFromBuffer .ReceivedData, oPacket, LenB(oPacket), lOffset
  706.         AppendText "Sent packet #" & CStr(oPacket.lPacketID) & " to " & GetName(dpnotify.idSender) & " - Size:" & CStr(oPacket.lDataSize)
  707.     End Select
  708.     End With
  709. End Sub
  710.  
  711. Private Sub DirectPlay8Event_SendComplete(dpnotify As DxVBLibA.DPNMSG_SEND_COMPLETE, fRejectMsg As Boolean)
  712.     If dpnotify.hResultCode = DPNERR_TIMEDOUT Then 'our packet timed out
  713.         AppendText "Packet Timed Out... "
  714.     End If
  715.     'The send has completed, so DPlay no longer has a need for our
  716.     'buffer, so we can get rid of it now.
  717.     Erase moByte
  718.     Erase moBuf
  719.     'Allow the next send to happen
  720.     mfInSend = False
  721. End Sub
  722.  
  723. Private Sub DirectPlay8Event_TerminateSession(dpnotify As DxVBLibA.DPNMSG_TERMINATE_SESSION, fRejectMsg As Boolean)
  724.     'This connection has been terminated.
  725.     If dpnotify.hResultCode = DPNERR_HOSTTERMINATEDSESSION Then
  726.         MsgBox "The host has terminated this session.  This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
  727.     Else
  728.         MsgBox "This session has been lost.  This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
  729.     End If
  730.     DPlayEventsForm.CloseForm Me
  731. End Sub
  732.  
  733.